home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / TOOLBAR.ZIP / TOOLBAR.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-27  |  24KB  |  900 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Toolbar unit                                 }
  5. {   Copyright (c) 1992 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit ToolBar;
  10.  
  11. interface
  12.  
  13. {$R Toolbar.res}
  14.  
  15. uses Winprocs, Wintypes, Objects, OWindows, Strings, Win31;
  16.  
  17. const
  18.   am_CalcParentClientRect = wm_User + 120;
  19.   tbHorizontal   = $01;
  20.   tbLeftVertical = $02;
  21.   tbRightVertical= $04;
  22.   DenyRepaint  = 0;
  23.   AllowRepaint = 1;
  24.  
  25. type
  26.  
  27.   PTool = ^TTool;
  28.   TTool = object(TObject)
  29.     Parent: PWindowsObject;
  30.     constructor Init(AParent: PWindowsObject);
  31.     function GetWidth: Integer; virtual;
  32.     function GetHeight: Integer; virtual;
  33.     function HitTest(P: TPoint): Boolean; virtual;
  34.     procedure Paint(DC, AMemDC: HDC; var PS: TPaintStruct); virtual;
  35.     procedure BeginCapture(P: TPoint); virtual;
  36.     procedure ContinueCapture(P: TPoint); virtual;
  37.     function EndCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  38.     function HasCommand(Command: Word): Boolean; virtual;
  39.     procedure Enable(State: Boolean); virtual;
  40.     procedure SetOrigin(X, Y: Integer); virtual; 
  41.     procedure Read(var S: TStream); virtual;
  42.     procedure Write(var S: TStream); virtual;
  43.   end;  
  44.  
  45.   PToolbar = ^TToolbar;
  46.   TToolbar = object(TWindow)
  47.     ResName: PChar;
  48.     Tools: TCollection;
  49.     Capture: PTool;
  50.     Orientation: Word;
  51.     constructor Init(AParent: PWindowsObject; AName: PChar; Orient: Word);
  52.     destructor Done; virtual;
  53.     constructor Load(var S: TStream);
  54.     procedure Store(var S: TStream); virtual;
  55.     function  CreateTool(Num: Integer; Origin: TPoint; Command: Word;
  56.       BitmapName: PChar): PTool; virtual;
  57.     procedure EnableTool(Command: Word; NewState: Boolean); virtual;
  58.     procedure FreeResName;
  59.     function  GetClassName: PChar; virtual;
  60.     procedure GetWindowClass(var WC: TWndClass); virtual;
  61.     procedure SetResName(NewName: PChar);
  62.     procedure NextToolOrigin(Num: Integer; var Origin: TPoint;
  63.       P: PTool); virtual;
  64.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  65.     procedure ReadResource; virtual;
  66.     function  GetOrientation: Word;  virtual;
  67.     procedure SetOrientation(NewOrient: Word);  virtual;
  68.     procedure SwitchTo(NewName: PChar);
  69.     procedure AMCalcParentClientRect(var Msg: TMessage);
  70.       virtual wm_First + AM_CalcParentClientRect;
  71.     procedure WMLButtonDown(var Msg: TMessage);
  72.       virtual wm_First + wm_LButtonDown;
  73.     procedure WMMouseMove(var Msg: TMessage);
  74.       virtual wm_First + wm_MouseMove;
  75.     procedure WMLButtonUp(var Msg: TMessage);
  76.       virtual wm_First + wm_LButtonUp;
  77.   end;
  78.  
  79.   PToolSpacer = ^TToolSpacer;
  80.   TToolSpacer = object(TTool)
  81.     Size: Integer;
  82.     constructor Init(AParent: PWindowsObject; ASize: Integer);
  83.     function GetWidth: Integer; virtual;
  84.     function GetHeight: Integer; virtual;
  85.   end;
  86.  
  87.   PToolButton = ^TToolButton;
  88.   TToolButton = object(TTool)
  89.     bmGlyph: HBitmap;
  90.     Command: Word;
  91.     Capturing, IsPressed, IsEnabled: Boolean;
  92.     R: TRect;
  93.     GlyphSize: TPoint;
  94.     CapDC, MemDC: HDC;
  95.     constructor Init(AParent: PWindowsObject; X, Y: Integer; ACommand: Word;
  96.       BitmapName: PChar);
  97.     destructor Done; virtual;
  98.     function HasCommand(ACommand: Word): Boolean; virtual;
  99.     procedure Enable(State: Boolean); virtual;
  100.     function GetWidth: Integer; virtual;
  101.     function GetHeight: Integer; virtual;
  102.     procedure SetOrigin(X, Y: Integer); virtual;
  103.     function HitTest(P: TPoint): Boolean; virtual;
  104.     procedure Paint(DC, AMemDC: HDC; var PS: TPaintStruct); virtual;
  105.     procedure PaintState(DC, AMemDC: HDC);
  106.     procedure BeginCapture(P: TPoint); virtual;
  107.     procedure ContinueCapture(P: TPoint); virtual;
  108.     function  EndCapture(SendTo: HWnd; P: TPoint): Boolean; virtual;
  109.     procedure PressIn;
  110.     procedure PressOut;
  111.     procedure Read(var S: TStream); virtual;
  112.     procedure Write(var S: TStream); virtual;  
  113.   end;
  114.  
  115. const
  116.   RToolbar: TStreamRec = (
  117.     ObjType: 12301;
  118.     VmtLink: Ofs(TypeOf(TToolbar)^);
  119.     Load:    @TToolbar.Load;
  120.     Store:   @TToolbar.Store);
  121.  
  122. implementation
  123.  
  124. { Unit wide resourcs }
  125.  
  126. var
  127.   WhitePen, DarkGrayPen, BlackPen: HPen;
  128.   GrayBrush, GrayingBrush: HBrush;
  129.  
  130. function Max(A, B: Integer): Integer;
  131. begin
  132.   if A > B then
  133.     Max := A
  134.   else
  135.     Max := B;
  136. end;
  137.  
  138. { TToolbar }
  139.  
  140. constructor TToolbar.Init(AParent: PWindowsObject; AName: PChar;
  141.   Orient: Word);
  142. begin
  143.   inherited Init(AParent, nil);
  144.   Attr.Style := ws_Child or ws_Visible or ws_Border;
  145.   SetFlags(wb_MDIChild, False);
  146.   DefaultProc := @DefWindowProc;
  147.   Attr.X := -1;
  148.   Attr.Y := -1;
  149.   Attr.W := 5;    
  150.   Attr.H := 5;
  151.   Capture := nil;
  152.   Orientation := Orient;
  153.   ResName := nil;
  154.   SetResName(AName);
  155.  
  156.   Tools.Init(8, 8);
  157.  
  158.   ReadResource;
  159. end;
  160.  
  161. destructor TToolbar.Done;
  162. begin
  163.   inherited Done;
  164.   Tools.Done;
  165.   FreeResName;
  166. end;
  167.  
  168. constructor TToolbar.Load(var S: TStream);
  169. var
  170.   X: Integer;
  171.  
  172.   procedure RestoreStates(P : PTool); far;
  173.   begin
  174.     P^.Read(S);
  175.   end;
  176.  
  177. begin
  178.   inherited Load(S);
  179.   Attr.Style := ws_Child or ws_Visible or ws_Border;
  180.   SetFlags(wb_MDIChild, False);
  181.   DefaultProc := @DefWindowProc;
  182.   Capture := nil;
  183.   S.Read(Orientation, SizeOf(Orientation));
  184.   Tools.Init(8,8);
  185.  
  186.   ResName := nil;
  187.   S.Read(X, SizeOf(X));
  188.   if X = 0 then
  189.     S.Read(PtrRec(ResName).Ofs, SizeOf(Word))
  190.   else
  191.     ResName := S.StrRead; 
  192.  
  193.   ReadResource;
  194.   if Status <> em_InvalidChild then
  195.     Tools.ForEach(@RestoreStates)
  196.   else
  197.     S.Status := stGetError;
  198. end;
  199.  
  200.  
  201. procedure TToolbar.Store(var S: TStream);
  202. var
  203.   X: Integer;
  204.  
  205.   procedure SaveStates(P : PTool); far;
  206.   begin
  207.     P^.Write(S);
  208.   end;
  209.  
  210. begin
  211.   inherited Store(S);
  212.   S.Write(Orientation, SizeOf(Orientation));
  213.   if HiWord(Longint(ResName)) <> 0 then
  214.   begin
  215.     X := 1;
  216.     S.Write(X, SizeOf(X));
  217.     S.StrWrite(ResName);
  218.   end
  219.   else
  220.   begin
  221.     X := 0;
  222.     S.Write(X, SizeOf(X));
  223.     S.Write(PtrRec(ResName).Ofs, SizeOf(Word));
  224.   end;
  225.   Tools.ForEach(@SaveStates);
  226. end;
  227.  
  228. procedure TToolbar.ReadResource;
  229. type
  230.   ResRec = record
  231.     Bitmap,
  232.     Command: Word;
  233.   end;
  234.  
  235.   PResArray = ^TResArray;
  236.   TResArray = array [1..$FFF0 div sizeof(ResRec)] of ResRec;
  237.  
  238. var
  239.   ResIdHandle: THandle;
  240.   ResDataHandle: THandle;
  241.   ResDataPtr: PResArray;
  242.   Count: Word;
  243.   X: Word;
  244.   Origin: TPoint;
  245.   BitInfo: TBitmap;
  246.   P: PTool;
  247.  
  248. begin
  249.   ResIDHandle := FindResource(HInstance, ResName, 'ToolBarData');
  250.   ResDataHandle := LoadResource(HInstance, ResIDHandle);
  251.   ResDataPtr := LockResource(ResDataHandle);
  252.   if (ResIDHandle = 0) or (ResDataHandle = 0) or (ResDataPtr = nil) then
  253.   begin
  254.     Status := em_InvalidChild;
  255.     Exit;
  256.   end;
  257.  
  258.   X := 0;
  259.   Origin.X := 2;
  260.   Origin.Y := 2;
  261.  
  262.   Count := PWord(ResDataPtr)^;
  263.   Inc(LongInt(ResDataPtr), SizeOf(Count)); { Skip Count }
  264.   for X := 1 to Count do
  265.     with ResDataPtr^[X] do
  266.     begin
  267.       P := CreateTool(X, Origin, Command, PChar(Bitmap));
  268.       if P <> nil then
  269.       begin
  270.         NextToolOrigin(X, Origin, P);
  271.         Tools.Insert(P);
  272.       end;
  273.     end;
  274.  
  275.   Inc(Attr.H, 8);
  276.   Inc(Attr.W, 8);
  277.  
  278.   UnlockResource(ResDataHandle);
  279.   FreeResource(ResDataHandle);
  280. end;
  281.  
  282. function TToolbar.GetOrientation: Word;
  283. begin
  284.   GetOrientation := Orientation;
  285. end;
  286.  
  287. procedure TToolbar.SetOrientation(NewOrient: Word);
  288. var
  289.   X: Integer;
  290.   Origin: TPoint;
  291.  
  292.   procedure ResetOrigins(P : PTool); far;
  293.   begin
  294.     P^.SetOrigin(Origin.X, Origin.Y);
  295.     NextToolOrigin(X, Origin, P);
  296.     Inc(X);
  297.   end;
  298.  
  299. begin
  300.   Orientation := NewOrient;
  301.   Attr.H := 5;
  302.   Attr.W := 5;
  303.   X := 0;
  304.   Origin.X := 2;
  305.   Origin.Y := 2;
  306.   Tools.ForEach(@ResetOrigins);
  307.   Inc(Attr.W, 8);
  308.   Inc(Attr.H, 8);
  309.   SetWindowPos(HWindow, 0, -1, -1, Attr.W, Attr.H,  swp_NoZOrder or
  310.     swp_NoRedraw);
  311. end;
  312.  
  313.  
  314. { You may override CreateTool to make Toolbar use a different
  315.   kind of ToolButton object }
  316.  
  317. function TToolbar.CreateTool(Num: Integer; Origin: TPoint;
  318.   Command: Word; BitmapName: PChar): PTool;
  319. begin
  320.   if Word(BitmapName) = 0 then
  321.     CreateTool := New(PToolSpacer, Init(@Self, Command))
  322.   else
  323.     CreateTool := New(PToolButton, Init(@Self, Origin.X, Origin.Y, Command,
  324.       BitmapName));
  325. end;
  326.  
  327. procedure TToolbar.EnableTool(Command: Word; NewState: Boolean);
  328. var
  329.   P: PTool;
  330.  
  331.   function FoundIt(P: PTool): Boolean; far;
  332.   begin
  333.     FoundIt := P^.HasCommand(Command);
  334.   end;
  335.  
  336. begin
  337.   P := Tools.FirstThat(@FoundIt);
  338.   if P <> nil then
  339.     P^.Enable(NewState);
  340. end; 
  341.  
  342. function TToolbar.GetClassName: PChar;
  343. begin
  344.   GetClassName := 'OWLToolbar';
  345. end;
  346.  
  347. procedure TToolbar.GetWindowClass(var WC: TWndClass);
  348. begin
  349.   TWindow.GetWindowClass(WC);
  350.   WC.hbrBackground := GetStockObject(LtGray_Brush);
  351. end;
  352.  
  353. { NextToolOrigin should the origin for the next tool button based upon the
  354.   current tool's size and the toolbar's primary orientation or layout
  355.   system (horizontal, vertical, palette or other).  This method is called in
  356.   the Toolbar's constructor after each tool that is added to the toolbar.
  357.  
  358.   The code below supports horizontal and vertical orientation.  Descendents
  359.   of TToolbar can override this method to implement other layout schemes.}
  360.  
  361. procedure TToolbar.NextToolOrigin(Num: Integer; var Origin: TPoint;
  362.   P: PTool);
  363. begin
  364.   case Orientation of
  365.     tbHorizontal :
  366.       begin
  367.         Inc(Origin.X, P^.GetWidth);
  368.         Attr.H := Max(Attr.H, P^.GetHeight);
  369.       end;
  370.    tbLeftVertical,
  371.    tbRightVertical:
  372.      begin
  373.        Inc(Origin.Y, P^.GetHeight);
  374.        Attr.W := Max(Attr.W, P^.GetWidth);
  375.      end;
  376.   end;
  377. end;
  378.  
  379. procedure TToolbar.Paint(DC: HDC; var PS: TPaintStruct);
  380. var
  381.   MemDC: HDC;
  382.   OldPen: HPen;
  383.  
  384.   procedure PaintIt(Item: PTool); far;
  385.   begin
  386.     Item^.Paint(DC, MemDC, PS);
  387.   end;
  388.  
  389. begin
  390.   OldPen := SelectObject(DC, WhitePen);
  391.   MoveTo(DC, 0, 0);
  392.   LineTo(DC, Attr.W + 1, 0);
  393.   SelectObject(DC, OldPen);
  394.   MemDC := CreateCompatibleDC(DC);
  395.   Tools.ForEach(@PaintIt);
  396.   DeleteDC(MemDC);
  397. end;
  398.  
  399. { FreeResName handles releasing memory, if necessary, occupied by a
  400.   PChar / integer resource identifier }
  401.  
  402. procedure TToolbar.FreeResName;
  403. begin
  404.   if HiWord(Longint(ResName)) <> 0 then
  405.     StrDispose(ResName);
  406. end;
  407.  
  408. { SetResName handles allocating memory, if necessary, to hold a PChar or
  409.   integer resource identifier. }
  410.  
  411. procedure TToolbar.SetResName(NewName: PChar);
  412. begin
  413.   FreeResName;
  414.   if HiWord(Longint(NewName)) <> 0 then
  415.     ResName := StrNew(NewName)
  416.   else
  417.     ResName := NewName;
  418. end;
  419.  
  420. { Switch the Toolbar object to use a different toolbar resource. }
  421.  
  422. procedure TToolbar.SwitchTo(NewName: PChar);
  423. begin
  424.   Tools.Done;
  425.   Tools.Init(8,8);
  426.   SetResName(NewName);
  427.   ReadResource;
  428. end;
  429.  
  430. { AMCalcParentClientRect is a message sent to the Toolbar by the main window.
  431.   LParam points to a TRect filled with the main window's client rectangle.
  432.   After passing this rect to each child window for possible modification,
  433.   the main window will use it to resize the MDI Client window.  You can
  434.   modify this rect to remove slices of the client window from any of the
  435.   four sides.  Horizontal toolbars slice off the top of the client rect,
  436.   while vertical toolbars take either a left or right slice.
  437.   Note that other 'special' windows, such as a status line, may also
  438.   modify the rect before or after the toolbar is given its chance.
  439.   Do not assume the rect always starts out as the main window's
  440.   full client area.  Base your calculations on the passed rect, not on
  441.   direct observation of the main window's true client rect.
  442.  
  443.   This message will be sent to the child windows in Z-Order.  In
  444.   situations where two special child windows might want to control the
  445.   same corner (ie a vertical and a horizontal toolbar vie for the same
  446.   corner), the window on top (first in ZOrder) will get the corner.  The
  447.   lower window should accept the relocated client origin (passed in LParam)
  448.   as the basis of owner-client origin calculations, so it will abut the
  449.   side of the higher child window.
  450.  
  451.   If Msg.wParam is zero, the child window should not repaint anything in
  452.   response to this message - the parent is only asking for info and doesn't
  453.   want the child windows to repaint themselves yet.  If Msg.WParam is
  454.   non-zero, the child may reposition or paint itself as needed to
  455.   synchronise with the new client rect.  The following
  456.   code keeps redraw flicker to an absolute minimum, so it's a little
  457.   more complicated than the trivial case of just always repainting
  458.   everything. }
  459.  
  460. procedure TToolbar.AMCalcParentClientRect( var Msg: TMessage);
  461. var
  462.   TB,               { Toolbar rect in screen coords }
  463.   PC,               { Parent client rect in screen coords  }
  464.   NewTB,            { New toolbar rect in screen coords    }
  465.   R   : TRect;      { scratch }
  466.   S2PC, S2TB: TPoint; { Screen to local coord. conversion offsets } 
  467.   XOfs : Integer;
  468. begin
  469.   PC := PRect(Msg.LParam)^;
  470.   R := PC;
  471.   ClientToScreen(Parent^.HWindow, PPoint(@PC)^);
  472.   ClientToScreen(Parent^.HWindow, PPoint(@PC.Right)^);
  473.   S2PC.X := PC.Left - R.Left;
  474.   S2PC.Y := PC.Top  - R.Top;
  475.  
  476.   GetWindowRect(HWindow, TB);
  477.   S2TB.X := TB.Left ;
  478.   S2TB.Y := TB.Top;
  479.  
  480.   if Orientation = tbHorizontal then
  481.   begin
  482.     if Bool(Msg.WParam) then  { We have permission to repaint & reposition }
  483.     begin
  484.       if TB.Right <> PC.Right then     { Parent client relative coords }
  485.         SetWindowPos(HWindow, 0, -1, -1, PC.Right - S2TB.X + 1,
  486.           TB.Bottom - S2TB.Y, swp_NoZOrder or swp_NoRedraw);
  487.       if TB.Right < PC.Right then
  488.       begin                      { Width increases, paint new area }
  489.         SetRect(R, TB.Right - S2TB.X - 2, TB.Top - S2TB.Y - 1, 
  490.           PC.Right - S2TB.X + 1, TB.Bottom - S2TB.Y +1);
  491.         InvalidateRect(HWindow, @R, True);
  492.       end;
  493.     end;
  494.     if PC.Top < TB.Bottom then
  495.       PC.Top := TB.Bottom;
  496.   end
  497.   else
  498.   if (Orientation and (tbLeftVertical or tbRightVertical)) <> 0 then
  499.   begin
  500.     if Orientation = tbRightVertical then
  501.       XOfs := PC.Right - (TB.Right - TB.Left) + 2
  502.     else
  503.       XOfs := PC.Left;
  504.     SetRect(NewTB, XOfs - 1, PC.Top  - 1, XOfs + (TB.Right - TB.Left) - 1,
  505.       PC.Bottom);
  506.     if Bool(Msg.WParam) then   { We have permission to repaint & reposition }
  507.     begin
  508.       if TB.Bottom <> PC.Bottom then
  509.         SetWindowPos(HWindow, 0, NewTB.Left - S2PC.X, NewTB.Top - S2PC.Y,
  510.           NewTB.Right - NewTB.Left, NewTB.Bottom - NewTB.Top + 1,
  511.           swp_NoZOrder or swp_NoRedraw);
  512.  
  513.       if (TB.Left <> NewTB.Left) or (TB.Top <> NewTB.Top) then
  514.       begin
  515.         InvalidateRect(HWindow, nil, True) { Window moved, paint it all }
  516.       end
  517.       else
  518.       if TB.Bottom < NewTB.Bottom then  { Height grew, paint new area }
  519.       begin
  520.         SetRect(R, NewTB.Left - S2TB.X - 1, TB.Bottom - S2TB.Y - 2,
  521.           NewTB.Right - S2TB.X, NewTB.Bottom - S2TB.Y);
  522.         InvalidateRect(HWindow, @R, True);
  523.       end;
  524.     end;
  525.  
  526.     if (Orientation = tbLeftVertical) and (PC.Left < NewTB.Right) then
  527.       PC.Left := NewTB.Right;
  528.     if (Orientation = tbRightVertical) and (PC.Right > NewTB.Left) then
  529.       PC.Right := NewTB.Left;
  530.   end;
  531.  
  532.   { Map the screen coord PC record back into parent relative coords }
  533.   SetRect(PRect(Msg.LParam)^, PC.Left - S2PC.X, PC.Top - S2PC.Y,
  534.     PC.Right - S2PC.X, PC.Bottom - S2PC.Y);
  535. end;
  536.  
  537. procedure TToolbar.WMLButtonDown(var Msg: TMessage);
  538.  
  539.   function IsHit(Item: PTool): Boolean; far;
  540.   begin
  541.     IsHit := Item^.HitTest(TPoint(Msg.LParam));
  542.   end;
  543.  
  544. begin
  545.   Capture := Tools.FirstThat(@IsHit);
  546.   if Capture <> nil then
  547.     Capture^.BeginCapture(TPoint(Msg.LParam));
  548. end;
  549.  
  550. procedure TToolbar.WMMouseMove(var Msg: TMessage);
  551. begin
  552.   if (Capture <> nil) then
  553.     Capture^.ContinueCapture(TPoint(Msg.LParam));
  554. end;
  555.  
  556. procedure TToolbar.WMLButtonUp(var Msg: TMessage); 
  557. begin
  558.   if (Capture <> nil) and Capture^.EndCapture(Parent^.HWindow,
  559.       TPoint(Msg.LParam)) then
  560.     Capture := nil;  
  561. end;
  562.  
  563. { TTool }
  564.  
  565. constructor TTool.Init(AParent: PWindowsObject);
  566. begin
  567.   Parent := AParent;
  568. end;
  569.  
  570. function TTool.GetWidth: Integer;
  571. begin
  572.   GetWidth := 0;
  573. end;
  574.  
  575. function TTool.GetHeight: Integer;
  576. begin
  577.   GetHeight := 0;
  578. end;
  579.  
  580. function TTool.HitTest(P: TPoint): Boolean;
  581. begin
  582.   HitTest := False;
  583. end;
  584.  
  585. procedure TTool.Paint(DC, AMemDC: HDC; var PS: TPaintStruct);
  586. begin
  587. end;
  588.  
  589. procedure TTool.BeginCapture(P: TPoint);
  590. begin
  591. end;
  592.  
  593. procedure TTool.ContinueCapture(P: TPoint);
  594. begin
  595. end;
  596.  
  597. function TTool.EndCapture(SendTo: HWnd; P: TPoint): Boolean;
  598. begin
  599. end;
  600.  
  601. procedure TTool.Enable(State: Boolean);
  602. begin
  603. end;
  604.  
  605. procedure TTool.SetOrigin(X, Y: Integer);
  606. begin
  607. end; 
  608.  
  609. function TTool.HasCommand(Command: Word): Boolean;
  610. begin
  611.   HasCommand := False;
  612. end;
  613.  
  614. procedure TTool.Read(var S: TStream);
  615. begin
  616. end;
  617.  
  618. procedure TTool.Write(var S: TStream);
  619. begin
  620. end; 
  621.  
  622. { TToolSpacer } 
  623.  
  624. constructor TToolSpacer.Init(AParent: PWindowsObject; ASize: Integer);
  625. begin
  626.   inherited Init(AParent);
  627.   Size := ASize;
  628. end;
  629.  
  630. function TToolSpacer.GetWidth: Integer;
  631. begin
  632.   GetWidth := Size;
  633. end;
  634.  
  635. function TToolSpacer.GetHeight: Integer;
  636. begin
  637.   GetHeight := Size;
  638. end;
  639.  
  640. { TToolButton }
  641.  
  642. const
  643.   BorderWidth = 2;
  644.  
  645. constructor TToolButton.Init(AParent: PWindowsObject; X, Y: Integer;
  646.   ACommand: Word; BitmapName: PChar);
  647. var
  648.   BI: TBitmap;
  649.   GrayBM, OldBM: HBitmap;
  650.   OldPen: HPen;
  651. begin
  652.   inherited Init(AParent);
  653.   CapDC := 0;
  654.   MemDC := 0;
  655.   IsPressed := False;
  656.   Capturing := False;
  657.   IsEnabled := True;
  658.   Command := ACommand;
  659.   bmGlyph := LoadBitmap(HInstance, BitmapName);
  660.   GetObject(bmGlyph, SizeOf(BI), @BI);
  661.   GlyphSize.X := BI.bmWidth;
  662.   GlyphSize.Y := BI.bmHeight;
  663.   SetRect(R, X, Y, X + BI.bmWidth + BorderWidth * 2, Y + BI.bmHeight +
  664.     BorderWidth * 2);
  665. end;
  666.  
  667. destructor TToolButton.Done;
  668. begin
  669.   if Capturing then
  670.   begin
  671.     DeleteDC(MemDC);
  672.     ReleaseDC(Parent^.HWindow, CapDC);
  673.     ReleaseCapture;
  674.   end;
  675.   if bmGlyph <> 0 then DeleteObject(bmGlyph);
  676.   inherited Done;
  677. end;
  678.  
  679. function TToolButton.HasCommand(ACommand: Word): Boolean;
  680. begin
  681.   HasCommand := Command = ACommand;
  682. end;
  683.  
  684. procedure TToolButton.Enable(State: Boolean);
  685. begin
  686.   if (IsEnabled <> State) and (Parent^.HWindow <> 0) then
  687.     InvalidateRect(Parent^.HWindow, @R, False);
  688.   IsEnabled := State;
  689. end;
  690.  
  691. function TToolButton.GetWidth: Integer;
  692. begin
  693.   GetWidth := R.Right - R.Left;
  694. end;
  695.  
  696. function TToolButton.GetHeight: Integer;
  697. begin
  698.   GetHeight := R.Bottom - R.Top;
  699. end;
  700.  
  701. procedure TToolButton.SetOrigin(X, Y: Integer);
  702. var
  703.   BI : TBitmap;
  704. begin
  705.   GetObject(bmGlyph, SizeOf(BI), @BI);
  706.   SetRect(R, X, Y, X + BI.bmWidth + BorderWidth * 2,
  707.     Y + BI.bmHeight + BorderWidth * 2);
  708. end;
  709.  
  710. function TToolButton.HitTest(P: TPoint): Boolean;
  711. begin
  712.   HitTest := Boolean(PtInRect(R, P));
  713. end;
  714.  
  715. { InitButtonBitmaps loads the button images that the tool button glyphs
  716.   will be copied onto.  TToolButton assumes all the tool buttons on the
  717.   toolbar will be the same size.  If you want variable sized (width or
  718.   height or both) tool buttons, create a descendent of TToolButton and
  719.   override this method to create or stretch the button image to suite
  720.   each tool's glyph size.  Creating bitmaps for each toolbutton uses more
  721.   memory than several toolbuttons referencing the same bitmap resource.
  722.   String names are used to identify the bitmaps to avoid integer id
  723.   collisions with other bitmaps in the application.
  724. }
  725.  
  726.  
  727. procedure TToolButton.Paint(DC, AMemDC: HDC; var PS: TPaintStruct);
  728. begin
  729.   PaintState(DC, AMemDC);
  730. end;
  731.  
  732. procedure TToolButton.PaintState(DC, AMemDC: HDC);
  733. var
  734.   OldBitmap: HBitmap;
  735.   OldBrush: HBrush;
  736.   OldPen: HPen;
  737.   Offset: Integer;
  738. begin
  739.   OldPen := SelectObject(DC, BlackPen);
  740.   OldBrush := SelectObject(DC, GrayBrush);
  741.   with R do
  742.   begin
  743.     Rectangle(DC, Left, Top, Right + 1, Bottom + 1);
  744.     if not IsPressed then
  745.     begin
  746.       Offset := BorderWidth;
  747.       SelectObject(DC, WhitePen);
  748.       MoveTo(DC, Left + 1, Bottom - 1);
  749.       LineTo(DC, Left + 1, Top + 1);
  750.       LineTo(DC, Right - 1, Top + 1);
  751.       SelectObject(DC, DarkGrayPen);
  752.       MoveTo(DC, Right - 1, Top + 1);
  753.       LineTo(DC, Right - 1, Bottom - 1);
  754.       LineTo(DC, Left + 1, Bottom - 1);
  755.     end
  756.     else
  757.     begin
  758.       Offset := BorderWidth + 1;
  759.       SelectObject(DC, DarkGrayPen);
  760.       MoveTo(DC, Left + 1, Bottom - 1);
  761.       LineTo(DC, Left + 1, Top + 1);
  762.       LineTo(DC, Right, Top + 1);
  763.     end;
  764.   end;
  765.  
  766.   OldBitmap := SelectObject(AMemDC, bmGlyph);
  767.   if IsEnabled then
  768.     BitBlt(DC, R.Left + Offset, R.Top + Offset, GlyphSize.X, GlyphSize.Y,
  769.       AMemDC, 0, 0, SrcCopy)
  770.   else
  771.   begin
  772.     UnRealizeObject(GrayingBrush);
  773.     OldBrush := SelectObject(DC, GrayingBrush);
  774.     BitBlt(DC, R.Left + Offset, R.Top + Offset, GlyphSize.X, GlyphSize.Y,
  775.       AMemDC, 0, 0, $00A803A9 {DPSoa});
  776.   end;
  777.  
  778.   SelectObject(DC, OldBrush);
  779.   SelectObject(DC, OldPen);
  780.   SelectObject(AMemDC, OldBitmap);
  781. end;
  782.  
  783. procedure TToolButton.PressIn;
  784. begin
  785.   if (not IsPressed) and IsEnabled then
  786.   begin
  787.     IsPressed := True;
  788.     PaintState(CapDC, MemDC);
  789.   end;
  790. end;
  791.  
  792. procedure TToolButton.PressOut;
  793. begin
  794.   if IsPressed then
  795.   begin
  796.     IsPressed := False;
  797.     PaintState(CapDC, MemDC);
  798.   end;
  799. end;
  800.  
  801. procedure TToolButton.BeginCapture(P: TPoint);
  802. begin
  803.   CapDC := GetDC(Parent^.HWindow);
  804.   MemDC := CreateCompatibleDC(CapDC);
  805.   IsPressed := False;
  806.   Capturing := True;
  807.   SetCapture(Parent^.HWindow);
  808.   if HitTest(P) then
  809.     PressIn;
  810. end;
  811.  
  812. procedure TToolButton.ContinueCapture(P: TPoint);
  813. begin
  814.   if HitTest(P) then
  815.     PressIn
  816.   else
  817.     PressOut;
  818. end;
  819.  
  820.  
  821. { The boolean function result of EndCapture indicates whether the tool button
  822.   has released the mouse capture or not.  The Toolbar should not clear its
  823.   capture field/state until the toolbutton says to.
  824.  
  825.   The SendTo parameter is the HWindow to notify that the tool button was clicked
  826.   upon, if such is the case.  This code emulates a menu command message, but
  827.   any message type could be used. }
  828.  
  829. function TToolButton.EndCapture(SendTo: HWnd; P: TPoint): Boolean;
  830. begin
  831.   if HitTest(P) then
  832.   begin
  833.     PressOut;
  834.     PostMessage(SendTo, wm_Command, Command, 0);
  835.   end;
  836.   EndCapture := True;
  837.   ReleaseCapture;
  838.   Capturing := False;
  839.   DeleteDC(MemDC);
  840.   ReleaseDC(Parent^.HWindow, CapDC);
  841.   MemDC := 0;
  842.   CapDC := 0;
  843. end;
  844.  
  845. { Toolbuttons are not Loaded from the stream, but instead are constructed
  846.   from the resource info and then allowed to read their state info from the stream.
  847.   Conversely, the toolbuttons write state info but are not stored on the
  848.   stream. }
  849.  
  850. procedure TToolButton.Read(var S: TStream);
  851. begin
  852.   S.Read(IsEnabled, SizeOf(IsEnabled));
  853. end;
  854.  
  855. procedure TToolButton.Write(var S: TStream);
  856. begin
  857.   S.Write(IsEnabled, SizeOf(IsEnabled));
  858. end;  
  859.  
  860. { Allocate unit wide resources }
  861. procedure AllocateResources;
  862. const
  863.   coDarkGray = $808080;
  864. var
  865.   LBrush: TLogBrush;
  866. begin
  867.   { Allocate graying brush (used to disable buttons) }
  868.   LBrush.lbStyle := bs_Pattern;
  869.   Word(LBrush.lbHatch) := LoadBitmap(HInstance, 'GrayingBitmap');
  870.   GrayingBrush := CreateBrushIndirect(LBrush);
  871.   DeleteObject(Word(LBrush.lbHatch));
  872.  
  873.   { Allocate drawing pens and brushes }
  874.   GrayBrush := GetStockObject(LtGray_Brush);
  875.   WhitePen := GetStockObject(White_Pen);
  876.   BlackPen := GetStockObject(Black_Pen);
  877.   DarkGrayPen := CreatePen(ps_Solid, 1, coDarkGray);
  878. end;
  879.  
  880. { Free allocate resources }
  881. procedure DeallocateResources;
  882. begin
  883.   DeleteObject(GrayingBrush);
  884.   DeleteObject(DarkGrayPen);
  885. end;
  886.  
  887. var
  888.   SaveExit: Pointer;
  889.  
  890. procedure ExitToolBar; far;
  891. begin
  892.   DeallocateResources;
  893.   ExitProc := SaveExit;
  894. end;
  895.  
  896. begin
  897.   SaveExit := ExitProc;
  898.   ExitProc := @ExitToolBar;
  899.   AllocateResources;
  900. end.